(**
 * @copyright (C) 2021 SML# Development Team.
 * @author Atsushi Ohori
 *)
structure ReifiedTerm =
struct
  structure FE = SMLFormat.FormatExpression

  fun format_if (thenFmt, elseFmt) true = thenFmt
    | format_if (thenFmt, elseFmt) false = elseFmt

  local
    open SMLFormat.FormatExpression
    open SMLFormat.BasicFormatters
  in
  fun iftrue (x, y) true = x
    | iftrue (x, y) false = y
  fun ifcons (x, y) (_::_) = x
    | ifcons (x, y) nil = y
  fun ifsome (x, y) (SOME _) = x
    | ifsome (x, y) NONE = y
  fun ifempty (x, y) "" = x
    | ifempty (x, y) _ = y
  fun join (nil, sep, y) () = y
    | join (x, sep, nil) () = x
    | join (x, sep, y) () = Sequence x :: Sequence sep :: Sequence y :: nil
  fun split sep "" = nil
    | split sep s =
      foldr (fn (x,z) => Term (size x, x) :: ifcons (Sequence sep :: z, nil) z)
            nil
            (String.fields (fn x => x = #"\n") s)
  val u = ()

  fun isTuple (x, y) map = if RecordLabel.isTupleMap map then x else y

  fun format_RecordLabelMap args map =
      format_list args (RecordLabel.Map.listItemsi map)

  fun format_RecordOrTuple (format_value, format_keyValue, sep) map =
      if RecordLabel.isTupleMap map
      then format_list (format_value, sep) (RecordLabel.Map.listItems map)
      else format_list (format_keyValue, sep) (RecordLabel.Map.listItemsi map)

  fun quotedLabel l =
      TermPrintUtils.format_string (RecordLabel.toString l)
  end

  (*%
   * @formatter(recordExp) format_RecordOrTuple
   * @formatter(recordField) format_format_recordField
   * @formatter(RecordLabel.Map.map) format_RecordLabelMap
   * @formatter(RecordLabel.label) RecordLabel.format_label
   * @formatter(quotedLabel) quotedLabel
   * @formatter(ReifiedTy.reifiedTy) ReifiedTy.format_reifiedTy
   * @formatter(int) TermPrintUtils.format_int
   * @formatter(int8) TermPrintUtils.format_int8
   * @formatter(int16) TermPrintUtils.format_int16
   * @formatter(int64) TermPrintUtils.format_int64
   * @formatter(quote) TermPrintUtils.format_string
   * @formatter(real) TermPrintUtils.format_real
   * @formatter(char) TermPrintUtils.format_char
   * @formatter(word) TermPrintUtils.format_word32
   * @formatter(word8) TermPrintUtils.format_word8
   * @formatter(word16) TermPrintUtils.format_word16
   * @formatter(word64) TermPrintUtils.format_word64
   * @formatter(real32) TermPrintUtils.format_real32
   * @formatter(intInf) TermPrintUtils.format_IntInf
   * @formatter(iftrue) iftrue
   * @formatter(ifsome) ifsome
   * @formatter(isTuple) isTuple
   *)
  (*%
   * @prefix toJSON_
   * @formatter(recordField) toJSON_format_recordField
   * @formatter(RecordLabel.Map.map) format_RecordLabelMap
   * @formatter(RecordLabel.label) RecordLabel.format_label
   * @formatter(quotedLabel) quotedLabel
   * @formatter(ReifiedTy.reifiedTy) ReifiedTy.format_reifiedTy
   * @formatter(int) TermPrintUtils.format_intJson
   * @formatter(int8) TermPrintUtils.format_int8Json
   * @formatter(int16) TermPrintUtils.format_int16Json
   * @formatter(int64) TermPrintUtils.format_int64Json
   * @formatter(quote) TermPrintUtils.format_string
   * @formatter(real) TermPrintUtils.format_realJson
   * @formatter(real32) TermPrintUtils.format_real32Json
   * @formatter(char) TermPrintUtils.format_char
   * @formatter(word) TermPrintUtils.format_word32
   * @formatter(word8) TermPrintUtils.format_word8
   * @formatter(word16) TermPrintUtils.format_word16
   * @formatter(word64) TermPrintUtils.format_word64
   * @formatter(intInf) TermPrintUtils.format_IntInf
   * @formatter(iftrue) iftrue
   * @formatter(ifsome) ifsome
   * @formatter(isTuple) isTuple
   *)
  datatype reifiedTerm
    = (*%
       * @format(term terms)
       * !N0{ "<" 2[ 1 terms(term)("," +2) ] 1 ">" }
       *)
      (*% @prefix toJSON_
       * @format(term terms)
       * !N0{ "[" 2[ 1 terms(term)("," +2) ] 1 "]" }
       *)
      ARRAY_PRINT of reifiedTerm array
    | (*%
       * @format(ty * boxed) "ARRAY"
       *)
      (*% @prefix toJSON_
       * @format(ty * boxed) "ARRAY"
       *)
      ARRAY of ReifiedTy.reifiedTy * boxed
    | (*%
       * @format(bool) bool
       *)
      (*% @prefix toJSON_
       * @format(bool) bool
       *)
      BOOL of bool
    | (*%
       * @format(boxed) "_"
       *)
      (*% @prefix toJSON_
       * @format(boxed) "BOXED"
       *)
      BOXED of boxed
    | (*%
       * @format "null"
       *)
      (*% @prefix toJSON_
       * @format "null"
       *)
      NULL
    | (*%
       * @format(ty) L8{ "null" +1 ":" +d ty }
       *)
      (*% @prefix toJSON_
       * @format(ty) L8{ "null" +1 ":" +d ty }
       *)
      NULL_WITHTy of ReifiedTy.reifiedTy
    | (*%
       * @format "BOUNDVAR"
       *)
      (*%
       * @prefix toJSON_
       * @format "BOUNDVAR"
       *)
      BOUNDVAR
    | (*%
       * @format(char) char
       *)
      (*% @prefix toJSON_
       * @format(char) char
       *)
      CHAR of char
    | (*%
       * @format(word) word
       *)
      (*% @prefix toJSON_
       * @format(word) word
       *) 
      CODEPTR of word64
    | (*%
       * @format(con * term opt * ty)
       * opt:ifsome()( L6{ con +1 2[ opt(term) ] }, con )
       *)
      (*% @prefix toJSON_
       * @format(con * term opt * ty)
       * opt:ifsome()( L6{ con +1 2[ opt(term) ] }, con )
       *)
      DATATYPE of string * reifiedTerm option * ReifiedTy.reifiedTy
    | (*%
       * @format(ty * term) "_"
       *)
      (*% @prefix toJSON_
       * @format(ty * term) "DYNAMIC"
       *)
      DYNAMIC of ReifiedTy.reifiedTy * boxed 
    | (*%
       * @format({exnName, hasArg})
       * hasArg:iftrue()( L6{ exnName 2[ +1 "..." ] }, exnName )
       *)
      (*% @prefix toJSON_
       * @format({exnName,hasArg}) "EXN"
       *)
      EXN of {exnName : string, hasArg : bool}
    | (*%
       * @format "EXNTAG"
       *)
      (*% @prefix toJSON_
       * @format "EXNTAG"
       *)
      EXNTAG
    | (*%
       * @format(int) int
       *)
      (*% @prefix toJSON_
       * @format(int) int
       *)
      INT32 of int
    | (*%
       * @format(int) int
       *)
      (*% @prefix toJSON_
       * @format(int) int
       *)
      INT8 of int8
    | (*%
       * @format(int) int
       *)
      (*% @prefix toJSON_
       * @format(int) int
       *)
      INT16 of int16
    | (*%
       * @format(int) int
       *)
      (*% @prefix toJSON_
       * @format(int) int
       *)
      INT64 of int64
    | (*%
       * @format "INTERNAL"
       *)
      (*% @prefix toJSON_
       * @format "INTERNAL"
       *)
      INTERNAL 
    | (*%
       * @format(int) int
       *)
      (*% @prefix toJSON_
       * @format(int) int
       *)
      INTINF of intInf
    | (*%
       * @format(term terms)
       * !N0{ "[" 2[ 1 terms(term)("," +2) ] 1 "]" }
       *)
      (*% @prefix toJSON_
       * @format(term terms)
       * !N0{ "[" 2[ 1 terms(term)("," +2) ] 1 "]" }
       *)
      LIST of reifiedTerm list
    | (*%
       * @format "_"
       *)
      (*% @prefix toJSON_
       * @format "OPAQUE"
       *)
      OPAQUE
    | (*%
       * @format(term opt * ty)
       * opt:ifsome()( L6{ "SOME" 2[ +1 opt(term) ] }, "NONE" )
       *)
      (*% @prefix toJSON_
       * @format(term opt * ty)
       * opt:ifsome()( L6{ "SOME" 2[ +1 opt(term) ] }, "NONE" )
       *)
      OPTION of reifiedTerm option * ReifiedTy.reifiedTy
    | (*%
       * @format(word) word
       *)
      (*% @prefix toJSON_
       * @format(word) word
       *)
      PTR of word64
    | (*%
       * @format(real) real
       *)
      (*% @prefix toJSON_
       * @format(real) real
       *)
      REAL32 of real32
    | (*%
       * @format(real) real
       *)
      (*% @prefix toJSON_
       * @format(real) real
       *)
      REAL64 of real
    | (*% 
       * @format(term terms)
       * !N0{
       *   terms:isTuple()("(", "{")
       *   2[ 1 terms:recordExp(term,term:recordField(term))("," +2) ]
       *   1 terms:isTuple()(")", "}")
       * }
       *)
      (*% @prefix toJSON_
       * @format(term terms)
       * !N0{ "{" 2[ 1 terms(term:recordField(term))("," +1) ] 1 "}" }
       *)
      RECORD of reifiedTerm RecordLabel.Map.map
    | (*% 
       * @format(label) "#" label
       *)
      (*% @prefix toJSON_
       * @format(label) "RECORDLABEL"
       *)
      RECORDLABEL of RecordLabel.label
    | (*%
       * @format(term) 
       * L6{ "ref" 2[ +1 term ] }
       *)
      (*% @prefix toJSON_
       * @format(term) "REF_PRINT"
       *)
      REF_PRINT of reifiedTerm
    | (*%
       * @format(ty * boxed) "REF"
       *)
      (*% @prefix toJSON_
       * @format(ty * boxed) "REF"
       *)
      REF of ReifiedTy.reifiedTy * boxed
    | (*%
       * @format(keyValue terms)
       * !N0{ "{" 2[ 1 terms(keyValue)("," +2) ] 1 "}" }
       * @format:keyValue(key * value)
       * { key:quote +1 "=>" +d value }
       *)
      (*% @prefix toJSON_
       * @format(keyValue terms) "SENVMAP"
       *)
      SENVMAP of (string * reifiedTerm) list
    | (*%
       * @format(keyValue terms)
       * !N0{ "{" 2[ 1 terms(keyValue)("," +2) ] 1 "}" }
       * @format:keyValue(key * value)
       * { "#" key +1 "=>" +d value }
       *)
      (*% @prefix toJSON_
       * @format(term terms) "RECORDLABELMAP"
       *)
      RECORDLABELMAP of (RecordLabel.label * reifiedTerm) list
    | (*%
       * @format(keyValue terms)
       * !N0{ "{" 2[ 1 terms(keyValue)("," +2) ] 1 "}" }
       * @format:keyValue(key * value)
       * { key +1 "=>" +d value }
       *)
      (*% @prefix toJSON_
       * @format(term terms) "IENVMAP"
       *)
      IENVMAP of (int * reifiedTerm) list
    | (*%
       * @format(string) string:quote
       *)
      (*% @prefix toJSON_
       * @format(string) string:quote
       *)
      STRING of string
    | (*%
       * @format "void"
       *)
      (*% @prefix toJSON_
       * @format "VOID"
       *)
      VOID 
    | (*%
       * @format(ty)
       * L8{ "void" +1 ":" +d ty }
       *)
      (*% @prefix toJSON_
       * @format(ty)
       * L8{ "void" +1 ":" +d ty }
       *)
      VOID_WITHTy of ReifiedTy.reifiedTy
    | (*%
       * @format "()"
       *)
      (*% @prefix toJSON_
       * @format "{}"
       *)
      UNIT 
    | (*%
       * @format(term terms)
       * !N0{ "<|" 2[ 1 terms(term)("," +2) ] 1 "|>" }
       *)
      (*% @prefix toJSON_ 
       * @format(term terms)
       * !N0{ "[" 2[ 1 terms(term)("," +2) ] 1 "]" }
       *)
      VECTOR_PRINT of reifiedTerm vector
    | (*%
       * @format(ty * boxed) "VECTOR"
       *)              
      (*% @prefix toJSON_ 
       * @format(ty * boxed) "VECTOR"
       *)
      VECTOR of ReifiedTy.reifiedTy * boxed
    | (*%
       * @format(word) word
       *)
      (*% @prefix toJSON_
       * @format(word) word
       *)
      WORD32 of word
    | (*%
       * @format(word) word
       *)
      (*% @prefix toJSON_
       * @format(word) word
       *)
      WORD8 of word8
    | (*%
       * @format(word) word
       *)
      (*% @prefix toJSON_
       * @format(word) word
       *)
      WORD16 of word16
    | (*%
       * @format(word) word
       *)
      (*% @prefix toJSON_
       * @format(word) word
       *)
      WORD64 of word64
    | (*%
       * @format(ptr) "fn"
       *)
      (*% @prefix toJSON_
       * @format({closure:ptr, ty}) "FUN"
       *)
      FUN of {closure:boxed, ty:ReifiedTy.reifiedTy}
    | (*%
       * @format "_"
       *)
      (*% @prefix toJSON_
       * @format "_"
       *)
      UNPRINTABLE 
    | (*%
       * @format "..."
       *)
      (*% @prefix toJSON_
       * @format "..."
       *)
      ELLIPSIS
    | (*%
       * @format "<builtin>"
       *)
      (*% @prefix toJSON_
       * @format "<builtin>"
       *)
      BUILTIN

  withtype 'a format_recordField
    = (*%
       * @format(label * value)
       * { label +d "=" 2[ +1 value ] }
       *)
      (*% @prefix toJSON_
       * @format(label * value)
       * { label:quotedLabel +d ":" 2[ +1 value ] }
       *)
      RecordLabel.label * 'a

  (*% *)
  (*% @prefix toJSON_ *)
  datatype 'a dyn
    = (*%
       * @format(term) "<dynamic>"
       *)
      (*%
       * @prefix toJSON_ 
       * @format(term) "<dynamic>"
       *)
      DYN of reifiedTerm

  fun toDynamic term = DYN term
  fun toReifiedTerm (DYN term) = term

  (* general-purpose toString functions; width should not be changed *)
  fun reifiedTermToString term =
      SMLFormat.prettyPrint nil (format_reifiedTerm term)
  fun reifiedTermToJSON term =
      SMLFormat.prettyPrint nil (toJSON_reifiedTerm term)

  (*%
   *)
  type path
    = (*%
       * @format(name names)
       * names(name)(".")
       *)
      string list

  (*%
   * @formatter(split) split
   * @formatter(ifsome) ifsome
   *)
  datatype idstatus 
    = (*%
       * @format({name, term, ty})
       * { "val" +d name +d "=" 2[ +1 term +2 ":" +d { ty:split()(+1) } ] }
       *)
      EXVAR of {name:string, term:reifiedTerm, ty:string}
    | (*%
       * @format({name, ty})
       * { "val" +d name 2[ +1 ":" +d { ty:split()(+1) } ] }
       *)
      EXVARTY of {name:string, ty:string}
    | (*%
       * @format({name, ty : ty tyOpt})
       * { "exception" +d name
       *   tyOpt:ifsome()( 2[ +1 "of" +d tyOpt(ty:split()(+1)) ], ) }
       *)
      EXEXN of {name:string, ty:string option}
    | (*%
       * @format({name, path})
       * { "exception" +d name +d "=" +d path }
       *)
      EXEXNREP of {name:string, path:string}

  fun mkEXEXNIdstatus string stringOption =
      EXEXN {name = string, ty = stringOption}

  fun mkEXEXNREPIdstatus string pathString =
      EXEXNREP {name = string, path = pathString}

  fun mkEXVarIdstatus string reifiedTerm tyString =
      EXVAR {name = string, term = reifiedTerm, ty = tyString}

  (*%
   * @formatter(split) split
   *)
  type tstr
    = (*%
       * @format(name * def)
       * def:split()(\n)
       *)
      string * string

  (*%
   *)
  type varE
    = (*%
       * @format(var vars)
       * vars(var)(\n)
       *)
      idstatus list

  (*%
   *)
  type tyE
    = (*%
       * @format(ty tys)
       * tys(ty)(\n)
       *)
      tstr list

  (*%
   * @extern(u) u
   * @formatter(join) join
   *)
  datatype env
    = (*%
       * @format({varE, tyE, strE : str strs})
       * u:join()( u:join()( tyE, \n, varE ), \n, strs(str)(\n) )
       *)
      (*%
       * @format({varE, tyE, strE : str strs})
       * strs(str)(\n)
       *)
      ENV of {varE:varE, tyE:tyE, strE:strentry list}

  withtype strentry
    = (*%
       * @format(name * env)
       * "structure" +d name +d "=" 2[ \n
       * "struct" 2[ u:join()("", \n, env) ] \n
       * "end" ]
       *)
     string * env

  type strE = strentry list
  fun mkENVenv varE tyE strE =
      ENV {varE = varE, tyE = tyE, strE = strE}

  (*%
   * @formatter(split) split
   *)
  type funE
    = (*%
       * @format(functor functors)
       * functors(functor:split()(\n))(\n)
       *)
      string list

  (*%
   * @formatter(split) split
   *)
  type sigE
    = (*%
       * @format(sigE)
       * sigE:split()(\n)
       *)
      string

  (*%
   * @extern(u) u
   * @formatter(join) join
   *)
  type topEnv
    = (*%
       * @format({Env, FunE, SigE})
       * u:join()( u:join()( u:join()( FunE, \n, SigE ), \n, Env ), \n, "" )
       *)
       {Env:env, FunE:funE, SigE:sigE}

  fun mkTopEnv env funE sigE =
       {Env = env, FunE = funE, SigE = sigE}

  val printTopEnvOutput = ref NONE

  fun defaultPrintTopEnvOutput s =
      print s handle IO.Io _ => () (* user may close stdOut *)

  fun printTopEnv width topEnv =
      (case !printTopEnvOutput of SOME f => f | NONE => fn _ => ())
        (SMLFormat.prettyPrint
           (case !printTopEnvOutput of
              NONE => [SMLFormat.OutputFunction defaultPrintTopEnvOutput,
                       SMLFormat.Columns width]
            | SOME _ => [SMLFormat.Columns width])
           (format_topEnv topEnv))

end
